Night Owl 6/Night Owl's Shareware - PDSI-006 - Night Owl Corp (1990).iso/026a/db3procs.zip/PROCS.PRG

Text File | 1991-02-18 | 19KB | 581 lines

*---> Procedure File:   Procs.prg
*---> Author:           Chris K. Kaufman
*---< Last#Update:      18-Feb-91
*---> Purpose:          Demonstration of useful procedures
*---> Called by:        Main.prg
*--.0,Qsds:             Menu.dbf, Menu.ndx, Sample.dbf, Sample.ndx

*---> This procedure file contains the following useful utilities
*---> menu      Displays a popup menu window using parameters
*--->           stored in menu.dbf, choices can be made by pressing
*--->           the key corresponding to a menu item or by using
*--->           the arrow keys to move the selection bar.
*---> errormsg  Displays an error message on line 24 of the
*--->           screen and waits for a key press.
*---> Title     Displays a centered title on line 0 of the screen.
*---> blankmenu Blanks the last menu displayed.
*---> clrwindow Clears a window on the screen
*---> dispinst  Displays instructions on line 23 of the screen
*--->           in the same color as the last menu.
*---> picklist  Displays a list of items from the currently selected
*--->           database to choose from.

procedure menu
*---> Menu displays popup menu.  Arrow keys allow selection bar to be scrolled,
*---> Pressing the first or key letter of any option moves selection bar to
*---> that option.  Pressing Enter returns selection number to calling
*---> procedure.  Other keystrokes are ignored.
*---> menuscrn is name of menu, used as index into menu database.
*---> selection is option command to return to calling procedure.
parameters mscrn, selection
*---> get menu information
select 9
seek mscrn
*---> check for menu system error
if found()
  *---> menu found
  *---> get menu colors
  mcolormenu = menu->colormenu
  mcolorbar  = menu->colorbar
  mcolorbord = menu->colorbord
  *---> draw border
  set color to &mcolorbord
  @top-1,left-1 to top+numoptions,left+optwidth double
  *---> display options
  set color to &mcolormenu
  selection = 0
  do while selection < numoptions
    textnorm = 'option'+ltrim(str(selection))
    @top+selection,left say substr(&textnorm,1,optwidth)
    selection = selection+1
  enddo
  *---> highlight first menu selection
  set color to &mcolorbar
  @top,left say substr(option0,1,optwidth)
  *---> display first menu description
  @23,0 say descr0
  *---> initialize loop variables
  response = 0
  previous = 0
  selection = 0
  *---> top of loop
  do while response <> 13
    response = 0
    *---> wait for keypress
    do while response = 0
      response = inkey()
    enddo
    *---> remember previous selection
    previous = selection
    *---> process keypress
    do case
      case response = 24
        *---> down arrow
        selection = mod(selection+1,numoptions)
      case response = 5
        *---> up arrow
        selection = mod(selection+numoptions-1,numoptions)
      case response >= 0
        *---> not an arrow key, check for option letters
        *---> convert to uppercase character
        chrresp = upper(chr(response))
        *---> find location in option string, location-1 is selection
        selection = at(chrresp,optstring)-1
        if (selection = -1) .or. (selection >= numoptions)
          *---> selection not found, restore previous
          selection = previous
        endif
      otherwise
        *---> function keys return negative values
    endcase
    if selection <> previous
      *---> move selection bar
      *---> write previous menu selection in normal (menu) color
      textnorm = 'option'+ltrim(str(previous))
      set color to &mcolormenu
      @top+previous,left say substr(&textnorm,1,optwidth)
      *---> write new menu selection in highlighted (bar) color
      texthigh = 'option'+ltrim(str(selection))
      set color to &mcolorbar
      @top+selection,left say substr(&texthigh,1,optwidth)
      texthigh = 'descr'+ltrim(str(selection))
      @23,0 say &texthigh
    endif
  enddo
else
  *---> menu not found
  do errormsg with 'Menu not available.  Press any key to continue.'
  *---> return -1 as menusel
  menusel = -1
endif
*---> return to calling procedure.
select 1
return

procedure errormsg
*---> display error message on last line, wait for keypress.
*---> message is string to display
parameters message
*---> display message in yellow on red, centered, at bottom of screen
set color to gr+/r
@24,int(40-len(message)/2) say message
*---> wait for keypress
do while inkey() = 0
enddo
*---> blank error
set color to
@24,0 say space(80)
*---> return to calling procedure
return

procedure title
*---> display title at top of screen
parameters title
set color to gr+/n
@0,0 say space(80)
@0,40-int(len(title)/2) say title
return

procedure blankmenu
*---> blank the last menu displayed
do clrwindow with menu->top-1,menu->left-1,menu->top+menu->numoptions,menu->left+menu->optwidth
return

procedure clrwindow
*---> blank window
parameters top,left,bottom,right
set color to
blankline = space(right-left+1)
ptr = top
do while ptr <= bottom
  @ ptr,left say blankline
  ptr = ptr+1
enddo
return

procedure dispinst
parameters message
*---> set color to match menu bar
color = menu->colorbar
set color to &color
*---> blank old message, display new message
@23,0 say space(80)
@23,0 say message
return

procedure picklist
*---> picklist displays a list of string expressions and allows the user to
*---> select one string to be returned.  up and down arrows allow scrolling
*---> dbf used is in current select area
parameters  strexpr, mcolormenu, mcolorbar, mcolorbord, top, left, numoptions
*---> draw border
set color to &mcolormenu
@ top-1,left-1 to top+numoptions,left+len(&strexpr) double
*---> initialize pointers
numsel = 0
offset = 0
*---> initialize loop variables
response = 0
previous = 0
selection = 0
*---> display options
do displist with selection
*---> top of loop
do while response <> 13 .and. response <> 27
  response = 0
  *---> wait for keypress
  do while response = 0
    response = inkey()
  enddo
  *---> process keypress
  do case
    case response = 3
      *---> page down
      if selection = numsel - 1
        *---> at bottom of window
        if numsel = numoptions
          *---> window is full, scroll
          offset = offset + numoptions - 1
          selection = 0
        endif
      else
        *---> move to bottom of window
        selection = numsel - 1
      endif
      do displist with selection
    case response = 5
      *---> up arrow
      do moveup
    case response = 18
      *---> page up
      if selection = 0
        if offset < numoptions - 1
          offset = 0
          selection = 0
        else
          offset = offset - numoptions + 1
        endif
      else
        offset = offset + numsel - numoptions
        selection = 0
      endif
      do displist with selection
    case response = 24
      *---> down arrow
      do movedown
    otherwise
      *---> ignore key
  endcase
enddo
if response = 27
  *---> picklist terminated with ESC
  *---> return eof()
  if .not. eof()
    go bottom
    skip
  endif
endif
*---> remove picklist
do clrwindow with top-1,left-1,top+numoptions,left+len(&strexpr)
*---> return to calling procedure.
return

procedure displist
*---> numsel is number of selections actually available
*---> point to string expression at record number offset.
parameters hisel
goto top
skip offset
numsel = 0
if eof()
*---> check for empty list
  do errormsg with 'No options to display.  Press any key to continue.'
else
  *---> display string expressions until numoptions have been displayed
  *---> or end of file is reached.
  do while (numsel < numoptions) .and. (.not. eof())
    if numsel = hisel
      *---> highlight menu option
      set color to &mcolorbar
    else
      *---> normal option
      set color to &mcolormenu
    endif
    @top+numsel, left say &strexpr
    *---> move pointer
    skip
    numsel = numsel + 1
  enddo
  *---> restore pointer to offset
  skip hisel-numsel
  *---> if end of list found blank remaining entries
  if numsel < numoptions
    set color to &mcolormenu
    blankopt = space(len(&strexpr))
    i = numsel
    do while i < numoptions
      @top+i,left say blankopt
      i = i+1
    enddo
  endif
endif
return

procedure movedown
if selection < numsel-1
  *---> display old selection in normal color
  set color to &mcolormenu
  @top+selection, left say &strexpr
  *---> move pointers
  selection = selection + 1
  skip
  *---> display new selection in highlit color
  set color to &mcolorbar
  @top+selection, left say &strexpr
else
  *---> at bottom of window
  *---> only scroll window if window is full
  if numsel = numoptions
    offset = offset+selection
    selection = 0
    do displist with selection
  endif
endif
return

procedure moveup
if selection > 0
  *---> display old selection in normal color
  set color to &mcolormenu
  @top+selection, left say &strexpr
  *---> move pointers
  selection = selection - 1
  skip -1
  *---> display new selection in highlit color
  set color to &mcolorbar
  @top+selection, left say &strexpr
else
  *---> at top of window, scroll 1 page and leave bar at bottom of window
  if offset < numoptions-1
    *---> too close to top of file, can't scroll full page
    selection = offset
    offset = 0
  else
    *---> scroll full page
    offset = offset-numoptions+1
    selection = numoptions-1
  endif
  do displist with selection
endif
return

procedure disphelp
*---> display help information
set color to r/n
@ 14,9 to 22,70 double
set color to gr+/n
@ 16, 10 say 'Move the menu selection bar with the cursor up and down keys'
@ 17, 10 say 'or by pressing the first capitalized letter of an option.   '
@ 18, 10 say 'Press the Enter key to activate the selection.  The bottom  '
@ 19, 10 say 'two lines of the screen display descriptions of menu options'
@ 20, 10 say 'and error messages.  Each menu item displays help on the    '
@ 21, 10 say 'corresponding procedure.                                    '
do dispinst with 'Menu descriptions and instructions display here.'
do errormsg with 'Error messages display here.  Press any key to continue.'
set color to
@14,0 clear
return

*---> The following procedures are called by Main.prg to explain/demonstrate
*---> procedures defined above.

procedure menuinf
*---> display information on menu
do dispinst with 'Menu procedure information.'
*---> display first bit of info.
set color to gr+/n
@15,0
text
The menu procedure is called with two parameters, the menu screen name and the
variable that the menu selection will be returned as.  All other information
is stored in menu.dbf in select area 9.  After a menu choice is made the select
area is set to one, and selection number 0..n is returned.
endtext
do errormsg with 'Press any key to continue...'
do clrwindow with 15,0,22,79
*---> display next bit of info.
set color to gr+/n
@15,0
text
The menu options that can be set in the menu.dbf file are the location of the
upper left hand corner of the menu, the colors of the menu, menu bar and menu
border, the number of options in the menu (1..20), the width of the menu
(1..20), the prompt for each menu choice, the description of each menu choice
that is displayed on line 23, and the characters that will be accepted to
select each of the menu items.
endtext
do errormsg with 'Press any key to continue...'
do clrwindow with 15,0,22,79
*---> display next bit of info.
set color to gr+/n
@15,0
text
The code for calling a menu is:
menusel = 0                          >>> initialize parameter to be passed
do menu with 'menu name ',menusel    >>> 'menu name ' is 10 character key
  do case                                       into menu.dbf
  case menusel=0                     >>> process menu options 0..n
    ...
  endcase
endtext
do errormsg with 'Press any key to continue...'
do clrwindow with 15,0,22,79
*---> display next bit of info.
set color to gr+/n
@15,0
text
Notes:  First menu option is 0, if you have 10 options they are 0..9
        After calling a menu you are returned to select area 1
        Window size is 2 greater than numoptions x optionwidth to allow
                for border around window.
        For best results use only 3 color for menu, menubar, and menuborder.
                for example: C1/C2, C1/C3 & C3/C2 or C1/C2, C2/C3, & C3/C1
endtext
do errormsg with 'Press any key to display a sub-menu'
subsel = 0
do title with 'S U B   M E N U  - Select an option and press <Enter>.'
do menu with 'sub menu 1', subsel
do blankmenu
do clrwindow with 15,0,22,79
return

procedure errmsginf
*---> display information on errormsg procedure
do dispinst with 'Errormsg procedure information.'
*---> display first bit of info.
set color to gr+/n
@15,0
text
The errormsg procedure is called with one parameter, the error message to
display.  The message is displayed centered on line 24 in yellow on red until a
key is pressed.  For example:

        do errormsg with 'Sample Error Message.  Press any key to continue.'

will display as shown below.
endtext
do errormsg with 'Sample Error Message.  Press any key to continue.'
do clrwindow with 15,0,22,79
return

procedure blmenuinf
*---> display information on blankmenu procedure
do dispinst with 'Blankmenu procedure information.'
*---> display first bit of info.
set color to gr+/n
@15,0
text
The blankmenu procedure blanks the previous menu (paints it black).
No parameters are passed.  The syntax is:

        do blankmenu
endtext
do errormsg with 'Press any key to blank the menu.'
do blankmenu
do clrwindow with 15,0,22,79
*---> display the next bit of info.
set color to gr+/n
@15,0
text
The menu has been blanked.
endtext
do errormsg with 'Press any key to return to the menu.'
do clrwindow with 15,0,22,79
return

procedure titleinf
*---> display information on title procedure
do dispinst with 'Title procedure information.'
*---> display first bit of info.
set color to gr+/n
@15,0
text
The title procedure is called with one parameter: the title to be displayed.
The title is displayed centerered on line 0 in yellow.  An example follows:

        do title with 'This is a new title line.'
endtext
do errormsg with 'Press any key to display the new title.'
do title with 'This is a new title line.'
do clrwindow with 15,0,22,79
*---> display the next bit of info.
set color to gr+/n
@15,0
text
The new title is displayed.
endtext
do errormsg with 'Press any key to return to the menu.'
do clrwindow with 15,0,22,79
return

procedure clrwininf
*---> display information on clrwindow procedure
do dispinst with 'Clrwindow procedure information.'
*---> display first bit of info.
set color to gr+/n
@15,0
text
The clrwindow procedure clears (paints black) a rectangular block of text.
The parameters passed are coordinates of the top left and bottom right
corners of the block.  For example, to clear a block of text from 10,35 to
17,45 the command:
        do clrwindow with 10,35,17,45
would be used.
endtext
do errormsg with 'Press any key to clear a window from 10,35 to 17,45.'
do clrwindow with 10,35,17,45
*---> display the next bit of info.
do dispinst with 'The window has been cleared.'
do errormsg with 'Press any key to return to the menu.'
do clrwindow with 15,0,22,79
return

procedure dinstinf
*---> display information on dispinst procedure
do dispinst with 'Dispinst procedure information.'
*---> display first bit of info.
set color to gr+/n
@15,0
text
The dispinst procedure displays instructions on line 24 in the current menubar
colors.  One parameter is passed: the message to be displayed.
the format is:
        do dispinst with 'dispinst display information on this line.'
endtext
do errormsg with 'Press any key to display the above message.'
do dispinst with 'dispinst display information on this line.'
do clrwindow with 15,0,22,79
*---> display the next bit of info.
set color to gr+/n
@15,0
text
The new instruction line has been displayed.
endtext
do errormsg with 'Press any key to return to the menu.'
do clrwindow with 15,0,22,79
return
procedure plistinf
*---> display information on picklist procedure
do dispinst with 'Picklist procedure information.'
*---> display first bit of info.
set color to gr+/n
@15,0
text
The picklist procedure allows the user to pick a record out of a database.  A
window is displayed with a field or an expression involving one or more fields.
The user can scroll up and down through the list using the up/down cursor keys
and the page up/page down keys.  A record in the database is chosen by pressing
enter when the desired information is highlighted in the window.  The procedure
returns with the selected record current.  If ESC is pressed the procedure
returns EOF().
endtext
do errormsg with 'Press any key to continue...'
do clrwindow with 15,0,22,79
*---> display the next bit of info.
set color to gr+/n
@15,0
text
When the procedure is called the parameters passed are the string expression to
display, the colors to use, the location of the top left corner of the window,
and the number of selections to display in the window.  The database must be in
the current selected area.  Filters and indexes may be active.
IMPORTANT:  The string expression must be of constant length.
endtext
do errormsg with 'Press any key to continue...'
do clrwindow with 15,0,22,79
*---> display the next bit of info.
set color to gr+/n
@15,0
text
Sample code for using a picklist follows:

        use sample index sample
        do picklist with 'last_name+", "+first_name+" "+middl_init+"."',
                 'w+/b', 'w+/r', 'r/b', 7, 1, 7

NOTE: The previous line was split to fit on the display.
endtext
do errormsg with 'Press any key to display picklist.'
do clrwindow with 15,0,22,79
use sample index sample
do picklist with 'last_name+", "+first_name+" "+middl_init+"."', 'w+/b', 'w+/r', 'r/b', 7, 1, 7
if eof()
  do dispinst with 'You pressed ESC to leave the pick list.'
else
  do dispinst with 'You selected '+trim(first_name)+' '+middl_init+'. '+last_name
endif
use
do errormsg with 'Press any key to return to the main menu.'
return